home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / tearoff.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  4.7 KB  |  137 lines
  1. ;;;;
  2. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  3. ;;;; 
  4. ;;;; Permission to use, copy, and/or distribute this software and its
  5. ;;;; documentation for any purpose and without fee is hereby granted, provided
  6. ;;;; that both the above copyright notice and this permission notice appear in
  7. ;;;; all copies and derived works.  Fees for distribution or use of this
  8. ;;;; software or derived works may only be charged with express written
  9. ;;;; permission of the copyright holder.  
  10. ;;;; This software is provided ``as is'' without express or implied warranty.
  11. ;;;;
  12. ;;;; This software is a derivative work of other copyrighted softwares; the
  13. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  14. ;;;;
  15. ;;;;
  16. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  17. ;;;;    Creation date:  8-Sep-1995 11:37
  18. ;;;; Last file update: 22-Feb-1996 11:19
  19. ;;;;
  20.  
  21. ;; Tk:tear-off-menu  --
  22. ;; Given the name of a menu, this procedure creates a torn-off menu
  23. ;; that is identical to the given menu (including nested submenus).
  24. ;; The new torn-off menu exists as a toplevel window managed by the
  25. ;; window manager.  The return value is the name of the new menu.
  26. ;;
  27. ;; Arguments:
  28. ;; w -            The menu to be torn-off (duplicated).
  29.  
  30. (define (Tk:tear-off-menu w)
  31.  
  32.   (define (Tk:menu-dup src dst)  ;; duplicate src menu into dst
  33.     (let ((args '()))
  34.       (for-each (lambda (option)
  35.           (unless (= (length option) 2)
  36.             (set! args `(,(car option) ,(list-ref option 4) ,@args))))
  37.         (src 'configure))
  38.       
  39.       (set! dst (apply Tk:menu dst args))
  40.       
  41.       (let ((last (src 'index "last")))
  42.     (unless (equal? last "none")
  43.       (let loop ((i (if (tk-get src :tearoff) 1 0)))
  44.         (when (<= i last)
  45.           (let ((args '())
  46.             (type (src 'type i)))
  47.         (for-each (lambda (option)
  48.                 (set! args 
  49.                   `(,(car option) ,(list-ref option 4) ,@args)))
  50.               (src 'entryconfigure i))
  51.         
  52.         (apply dst 'add type args)
  53.         
  54.         (if (equal? type "cascade")
  55.             (let* ((name (format #f "~A.m~A" (widget-name dst) i))
  56.                (m2   (src 'entrycget i :menu)))
  57.               (if m2
  58.               (begin
  59.                 (Tk:menu-dup m2 name)
  60.                 (dst 'entryconfigure i :menu name))
  61.               (dst 'entryconfigure i :menu ""))))
  62.         
  63.         (loop (+ i 1)))))))
  64.  
  65.       ;; Duplicate the binding tags and bindings from the source menu.
  66.       ;
  67.       ;    regsub -all . $src {\\&} quotedSrc
  68.       ;    regsub -all . $dst {\\&} quotedDst
  69.       ;    regsub -all $quotedSrc [bindtags $src] $dst x
  70.       ;    bindtags $dst $x
  71.       ;    foreach event [bind $src] {
  72.       ;       regsub -all $quotedSrc [bind $src $event] $dst x
  73.       ;       bind $dst $event $x
  74.       ;    }
  75.       ;
  76.       ; Is it really useful? Should we duplicate bindings on the copy?
  77.       ; Furthermore, most of the time this code should do nothing (even if
  78.       ; necessary for completude).
  79.       ; Eventually translate this Tcl code in STk but don't use regexp
  80.       ; since they could not be compiled for STk
  81.       
  82.       ;; Return dst as result
  83.       dst))
  84.   
  85.  
  86.   ;;******** Start of Tk:tear-off-menu
  87.  
  88.   ;; Find a unique name to use for the torn-off menu.  Find the first
  89.   ;; ancestor of w that is a toplevel but not a menu, and use this as
  90.   ;; the parent of the new menu.  This guarantees that the torn off
  91.   ;; menu will be on the same screen as the original menu.  By making
  92.   ;; it a child of the ancestor, rather than a child of the menu, it
  93.   ;; can continue to live even if the menu is deleted;  it will go
  94.   ;; away when the toplevel goes away.
  95.  
  96.   (let ((parent [winfo 'parent w]))
  97.     (while (or (not (equal? parent [winfo 'toplevel parent]))
  98.            (equal? (winfo 'class parent) "Menu"))
  99.     (set! parent [winfo 'parent parent]))
  100.  
  101.     (let ((menu (Tk:menu-dup w (format #f "~A.~A" 
  102.                        (if (equal? parent *root*) 
  103.                        "" 
  104.                        (widget-name parent))
  105.                        (gensym "tear__off")))))
  106.       (tk-set! menu :transient #f)
  107.       
  108.       ;; Pick a title for the new menu by looking at the parent of the
  109.       ;; original: if the parent is a menu, then use the text of the active
  110.       ;; entry.  If it's a menubutton then use its text.
  111.       
  112.       (set! parent [winfo 'parent w])
  113.       (wm 'title menu (cond
  114.                  ((string=? [winfo 'class parent] "Menubutton")
  115.                   (tk-get parent :text))
  116.              ((string=? [winfo 'class parent] "Menu")
  117.                   (parent 'entrycget "active" :label))
  118.              (ELSE "Menu")))
  119.  
  120.       (tk-set! menu :tearoff #f)
  121.       (menu 'post [winfo 'x w] [winfo 'y w])
  122.       
  123.       ;; Set tk::focus on entry:  otherwise the focus will get lost
  124.       ;; after keyboard invocation of a sub-menu (it will stay on the
  125.       ;; submenu).
  126.  
  127.       (bind menu "<Enter>" (lambda (|W|)
  128.                  (set! tk::focus |W|)))
  129.  
  130.       ;; If there is a :tearoffcommand option for the menu, invoke it
  131.       ;; now.
  132.       (let ((cmd (tk-get w :tearoffcommand)))
  133.     (unless (equal? cmd "")
  134.       (cmd w menu))))))
  135.  
  136.  
  137.